home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Atari Mega Archive 1
/
Atari Mega Archive - Volume 1.iso
/
language
/
pcl_src.zoo
/
pcl-env.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1992-07-09
|
65KB
|
1,632 lines
;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox PARC
;;; 3333 Coyote Hill Rd.
;;; Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.com)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; Xerox-Lisp specific environment hacking for PCL
(in-package "PCL")
;;
;; Protect the Corporation
;;
(eval-when (eval load)
(format *terminal-io*
"~&;PCL-ENV Copyright (c) 1987, 1988, 1989, by ~
Xerox Corporation. All rights reserved.~%"))
;;; Make funcallable instances (FINs) print by calling print-object.
(eval-when (eval load)
(il:defprint 'il:compiled-closure 'il:print-closure))
(defun il:print-closure (x &optional stream depth)
;; See the IRM, section 25.3.3. Unfortunatly, that documentation is
;; not correct. In particular, it makes no mention of the third argument.
(cond ((not (funcallable-instance-p x))
;; IL:\CCLOSURE.DEFPRINT is the orginal system function for
;; printing closures
(il:\\cclosure.defprint x stream))
((streamp stream)
;; Use the standard PCL printing method, then return T to tell
;; the printer that we have done the printing ourselves.
(print-object x stream)
t)
(t
;; Internal printing (again, see the IRM section 25.3.3).
;; Return a list containing the string of characters that
;; would be printed, if the object were being printed for
;; real.
(with-output-to-string (stream)
(list (print-object x stream))))))
;;; Naming methods
(defun gf-named (gf-name)
(let ((spec (cond ((symbolp gf-name) gf-name)
((and (consp gf-name)
(eq (first gf-name) 'setf)
(symbolp (second gf-name))
(null (cddr gf-name)))
(get-setf-function-name (second gf-name)))
(t nil))))
(if (and (fboundp spec)
(generic-function-p (symbol-function spec)))
(symbol-function spec)
nil)))
(defun generic-function-method-names (gf-name hasdefp)
(if hasdefp
(let ((names nil))
(maphash #'(lambda (key value)
(declare (ignore value))
(when (and (consp key) (eql (car key) gf-name))
(pushnew key names)))
(gethash 'methods xcl:*definition-hash-table*))
names)
(let ((gf (gf-named gf-name)))
(when gf
(mapcar #'full-method-name (generic-function-methods gf))))))
(defun full-method-name (method)
"Return the full name of the method"
(let ((specializers (mapcar #'(lambda (x)
(cond ((eq x 't) t)
((consp x) x)
(t (class-name x))))
(method-type-specifiers method))))
;; Now go through some hair to make sure that specializer is
;; really right. Once PCL returns the right value for
;; specializers this can be taken out.
(let* ((arglist (method-arglist method))
(number-required (or (position-if
#'(lambda (x) (member x lambda-list-keywords))
arglist)
(length arglist)))
(diff (- number-required (length specializers))))
(when (> diff 0)
(setq specializers (nconc (copy-list specializers)
(make-list diff :initial-element 't)))))
(make-full-method-name (generic-function-name
(method-generic-function method))
(method-qualifiers method)
specializers)))
(defun make-full-method-name (generic-function-name qualifiers arg-types)
"Return the full name of a method, given the generic-function name, the method
qualifiers, and the arg-types"
;; The name of the method is:
;; (<generic-function-name> <qualifier-1> ..
;; (<arg-specializer-1>..))
(labels ((remove-trailing-ts (l)
(if (null l)
nil
(let ((tail (remove-trailing-ts (cdr l))))
(if (null tail)
(if (eq (car l) 't)
nil
(list (car l)))
(if (eq l tail)
l
(cons (car l) tail)))))))
`(,generic-function-name ,@qualifiers
,(remove-trailing-ts arg-types))))
(defun parse-full-method-name (method-name)
"Parse the method name, returning the gf-name, the qualifiers, and the
arg-types."
(values (first method-name)
(butlast (rest method-name))
(car (last method-name))))
(defun prompt-for-full-method-name (gf-name &optional has-def-p)
"Prompt the user for the full name of a method on the given generic function name"
(let ((method-names (generic-function-method-names gf-name has-def-p)))
(cond ((null method-names)
nil)
((null (cdr method-names))
(car method-names))
(t (il:menu
(il:create
il:menu il:items il:_ ;If HAS-DEF-P, include only
; those methods that have a
; symbolic def'n that we can
; find
(remove-if #'null
(mapcar #'(lambda (m)
(if (or (not has-def-p)
(il:hasdef m 'methods))
`(,(with-output-to-string (s)
(dolist (x m)
(format s "~A " x))
s)
',m)
nil))
method-names))
il:title il:_ "Which method?"))))))
;;; Converting generic defining macros into DEFDEFINER macros
(defmacro make-defdefiner (definer-name definer-type type-description &body
definer-options)
"Make the DEFINER-NAME use DEFDEFINER, defining items of type DEFINER-TYPE"
(let ((old-definer-macro-name (intern (string-append definer-name
" old definition")
(symbol-package definer-name)))
(old-definer-macro-expander (intern (string-append definer-name
" old expander")
(symbol-package definer-name))))
`(progn
;; First, move the current defining function off to some safe
;; place
(unmake-defdefiner ',definer-name)
(cond ((not (fboundp ',definer-name))
(error "~A has no definition!" ',definer-name))
((fboundp ',old-definer-macro-name))
((macro-function ',definer-name)
; We have to move the macro
; expansion function as well,
; so it won't get clobbered
; when the original macro is
; redefined. See AR 7410.
(let* ((expansion-function (macro-function ',definer-name)))
(setf (symbol-function ',old-definer-macro-expander)
(loop (if (symbolp expansion-function)
(setq expansion-function
(symbol-function expansion-function))
(return expansion-function))))
(setf (macro-function ',old-definer-macro-name)
',old-definer-macro-expander)
(setf (get ',definer-name 'make-defdefiner) expansion-function)))
(t (error "~A does not name a macro." ',definer-name)))
;; Make sure the type is defined
(xcl:def-define-type ,definer-type ,type-description)
;; Now redefine the definer, using DEFEDFINER and the original def'n
(xcl:defdefiner ,(if definer-options
(cons definer-name definer-options)
definer-name)
,definer-type (&body b) `(,',old-definer-macro-name ,@,'b)))))
(defun unmake-defdefiner (definer-name)
(let ((old-expander (get definer-name 'make-defdefiner)))
(when old-expander
(setf (macro-function definer-name old-expander))
(remprop definer-name 'make-defdefiner))))
;;; For tricking ED into being able to use just the generic-function-name
;;; instead of the full method name
(defun source-manager-method-edit-fn (name type source editcoms options)
"Edit a method of the given name"
(let ((full-name (if (gf-named name)
;If given the name of a
; generic-function, try to get
; the full method name
(prompt-for-full-method-name name t)
; Otherwise it should name the
; method
name)))
(when (not (null full-name))
(il:default.editdef full-name type source editcoms options))
(or full-name name))) ;Return the name
(defun source-manager-method-hasdef-fn (name type &optional source)
"Is there a method defined with the given name?"
(cond ((not (eq type 'methods)) nil)
((or (symbolp name)
(and (consp name)
(eq (first name) 'setf)
(symbolp (second name))
(null (cddr name))))
;; If passed in the name of a generic-function, pretend that
;; there is a method by that name if there is a generic function
;; by that name, and there is a method whose source we can find.
(if (and (not (null (gf-named name)))
(find-if #'(lambda (m)
(il:hasdef m type source))
(generic-function-method-names name t)))
name
nil))
((and (consp name) (>= (length name) 2))
;; Standard methods are named (gf-name {qualifiers}* ({specializers}*))
(when (il:getdef name type source '(il:nocopy il:noerror))
name))
(t
;; Nothing else can name a method
nil)))
;;; Initialize the PCL env
(defun initialize-pcl-env nil
"Initialize the Xerox PCL environment"
;; Set up SourceManager DEFDEFINERS for classes and methods.
;;
;; Make sure to define methods before classes, so that (IL:FILES?) will build
;; filecoms that have classes before methods.
(unless (il:hasdef 'methods 'il:filepkgtype)
(make-defdefiner defmethod methods "methods"
(:name (lambda (form)
(multiple-value-bind (name qualifiers arglist)
(parse-defmethod (cdr form))
(make-full-method-name name qualifiers
(extract-specializer-names
arglist)))))
(:undefiner
(lambda (method-name)
(multiple-value-bind
(name qualifiers arg-types)
(parse-full-method-name method-name)
(let* ((gf (gf-named name))
(method (when gf
(get-method gf qualifiers
(mapcar #'find-class
arg-types)))))
(when method (remove-method gf method))))))))
;; Include support for DEFGENERIC, if that is defined
(unless (or (not (fboundp 'defgeneric))
(il:hasdef 'generic-functions 'il:filepkgtype))
(make-defdefiner defgeneric generic-functions "generic-function definitions"))
;; DEFCLASS FileManager stuff
(unless (il:hasdef 'classes 'il:filepkgtype)
(make-defdefiner defclass classes "class definitions"
(:undefiner (lambda (name)
(when (find-class name t)
(setf (find-class name) nil)))))
;; CLASSES "include" TYPES.
(il:filepkgcom 'classes 'il:contents
#'(lambda (com name type &optional reason)
(declare (ignore name reason))
(if (member type '(il:types classes) :test #'eq)
(cdr com)
nil))))
;; Set up the hooks so that ED can be handed the name of a generic function,
;; and end up editing a method instead
(il:filepkgtype 'methods 'il:editdef 'source-manager-method-edit-fn
'il:hasdef 'source-manager-method-hasdef-fn)
;; Set up the inspect macro. The right way to do this is to
;; (ENSURE-GENERIC-FUNCTION 'IL:INSPECT...), but for now...
(push '((il:function pcl-object-p) . \\internal-inspect-object)
il:inspectmacros)
;; Unmark any SourceManager changes caused by this loadup
(dolist (com (il:filepkgchanges))
(dolist (name (cdr com))
(when (and (symbolp name)
(eq (symbol-package name) (find-package "PCL")))
(il:unmarkaschanged name (car com))))))
(eval-when (eval load)
(initialize-pcl-env))
;;; Inspecting PCL objects
(defun pcl-object-p (x)
"Is the datum a PCL object?"
(or (std-instance-p x)
(fsc-instance-p x)
#+pcl-user-instances
(user-instance-p x)))
(defun \\internal-inspect-object (x type where)
(inspect-object x type where))
(defun \\internal-inspect-slot-names (x)
(inspect-slot-names x))
(defun \\internal-inspect-slot-value (x slot-name)
(inspect-slot-value x slot-name))
(defun \\internal-inspect-setf-slot-value (x slot-name value)
(inspect-setf-slot-value x slot-name value))
(defun \\internal-inspect-slot-name-command (slot-name x window)
(inspect-slot-name-command slot-name x window))
(defun \\internal-inspect-title (x y)
(inspect-title x y))
(defmethod inspect-object (x type where)
"Open an insect window on the object x"
(il:inspectw.create x '\\internal-inspect-slot-names
'\\internal-inspect-slot-value
'\\internal-inspect-setf-slot-value
'\\internal-inspect-slot-name-command nil nil
'\\internal-inspect-title nil where
#'(lambda (n v) ;Same effect as NIL, but avoids bug in
(declare (ignore v)) ; INSPECTW.CREATE
n)))
(defmethod inspect-slot-names (x)
"Return a list of names of slots of the object that should be shown in the
inspector"
(mapcar #'(lambda (slotd) (slot-value slotd 'name))
(slots-to-inspect (class-of x) x)))
(defmethod inspect-slot-value (x slot-name)
(cond ((not (slot-exists-p x slot-name)) "** no such slot **")
((not (slot-boundp x slot-name)) "** slot not bound **")
(t (slot-value x slot-name))))
(defmethod inspect-setf-slot-value (x slot-name value)
"Used by the inspector to set the value fo a slot"
;; Make this UNDO-able
(il:undosave `(inspect-setf-slot-value ,x ,slot-name
,(slot-value x slot-name)))
;; Then change the value
(setf (slot-value x slot-name) value))
(defmethod inspect-slot-name-command (slot-name x window)
"Allows the user to select a menu item to change a slot value in an inspect
window"
;; This code is a very slightly hacked version of the system function
;; DEFAULT.INSPECTW.PROPCOMMANDFN. We have to do this because the
;; standard version makes some nasty assumptions about
;; structure-objects that are not true for PCL objects.
(declare (special il:|SetPropertyMenu|))
(case (il:menu (cond ((typep il:|SetPropertyMenu| 'il:menu)
il:|SetPropertyMenu|)
(t (il:setq il:|SetPropertyMenu|
(il:|create| il:menu il:items il:_
'((set 'set
"Allows a new value to be entered"
)))))))
(set
;; The user want to set the value
(il:ersetq (prog ((il:oldvalueitem (il:itemofpropertyvalue slot-name
window))
il:newvalue il:pwindow)
(il:ttydisplaystream (il:setq il:pwindow
(il:getpromptwindow window 3)))
(il:clearbuf t t)
(il:resetlst
(il:resetsave (il:\\itemw.flipitem il:oldvalueitem window)
(list 'il:\\itemw.flipitem
il:oldvalueitem window))
(il:resetsave (il:tty.process (il:this.process)))
(il:resetsave (il:printlevel 4 3))
(il:|printout| t "Enter the new "
slot-name " for " x t
"The expression read will be EVALuated."
t "> ")
(il:setq il:newvalue (il:lispx (il:lispxread t t)
'>))
; clear tty buffer because it
; sometimes has stuff left.
(il:clearbuf t t))
(il:closew il:pwindow)
(return (il:inspectw.replace window slot-name il:newvalue)))))))
(defmethod inspect-title (x window)
"Return the title to use in an inspect window viewing x"
(format nil "Inspecting a ~A" (class-name (class-of x))))
(defmethod inspect-title ((x standard-class) window)
(format nil "Inspecting the class ~A" (class-name x)))
;;; Debugger support for PCL
(il:filesload pcl-env-internal)
;; Non-PCL specific changes to the debugger
;; Redefining the standard INTERESTING-FRAME-P function. Now functions can be
;; declared uninteresting to BT by giving them an XCL::UNINTERESTINGP
;; property.
(dolist (fn '(si::*unwind-protect* il:*env*
evalhook xcl::nohook xcl::undohook
xcl::execa0001 xcl::execa0001a0002
xcl::|interpret-UNDOABLY|
cl::|interpret-IF| cl::|interpret-FLET|
cl::|interpret-LET| cl::|interpret-LETA0001|
cl::|interpret-BLOCK| cl::|interpret-BLOCKA0001|
il:do-event il:eval-input
apply t))
(setf (get fn 'xcl::uninterestingp) t))
(defun xcl::interesting-frame-p (xcl::pos &optional xcl::interpflg)
"Return TRUE iff the frame should be visible for a short backtrace."
(declare (special il:openfns))
(let ((xcl::name (if (il:stackp xcl::pos) (il:stkname xcl::pos) xcl::pos)))
(typecase xcl::name
(symbol (case xcl::name
(il:*env*
;; *ENV* is used by ENVEVAL etc.
nil)
(il:errorset
(or (<= (il:stknargs xcl::pos) 1)
(not (eq (il:stkarg 2 xcl::pos nil)
'il:internal))))
(il:eval
(or (<= (il:stknargs xcl::pos) 1)
(not (eq (il:stkarg 2 xcl::pos nil)
'xcl::internal))))
(il:apply
(or (<= (il:stknargs xcl::pos) 2)
(not (il:stkarg 3 xcl::pos nil))))
(otherwise
(cond ((get xcl::name 'xcl::uninterestingp)
;; Explicitly declared uninteresting.
nil)
((eq (il:chcon1 xcl::name) (char-code #\\))
;; Implicitly declared uninteresting by starting the
;; name with a "\".
nil)
((or (member xcl::name il:openfns :test #'eq)
(eq xcl::name 'funcall))
;;The function won't be seen when compiled, so only show
;;it if INTERPFLG it true
xcl::interpflg)
(t
;; Interesting by default.
t)))))
(cons (case (car xcl::name)
(:broken t)
(otherwise nil)))
(otherwise nil))))
(setq il:*short-backtrace-filter* 'xcl::interesting-frame-p)
(eval-when (eval compile)
(il:record il:bkmenuitem (il:label (il:bkmenuinfo il:frame-name))))
;; Change the frame inspector to open up lexical environments
;; Since the DEFSTRUCT is going to build the accessors in the package that is
;; current at read-time, and we want the accessors to reside in the IL
;; package, we have got to make sure that the defstruct happens when the
;; package is IL.
(in-package "IL")
(cl:defstruct (frame-prop-name (:type cl:list))
(label-fn 'nill)
(value-fn
(function
(lambda (prop-name framespec)
(frame-prop-name-data prop-name))))
(setf-fn 'nill)
(inspect-fn
(function
(lambda (value prop-name framespec window)
(default.inspectw.valuecommandfn value prop-name (car framespec) window))))
(data nil))
(cl:in-package "PCL")
(defun il:debugger-stack-frame-prop-names (il:framespec)
;; Frame prop-names are structures of the form
;; (LABEL-FN VALUE-FN SETF-FN EDIT-FN DATA)
(let ((il:pos (car il:framespec))
(il:backtrace-item (cadr il:framespec)))
(il:if (eq 'eval (il:stkname il:pos))
il:then
(let ((il:expression (il:stkarg 1 il:pos))
(il:environment (il:stkarg 2 il:pos)))
`(,(il:make-frame-prop-name :inspect-fn
(il:function
(il:lambda (il:value il:prop-name il:framespec il:window)
(il:inspect/as/function il:value (car il:framespec) il:window)))
:data il:expression)
,(il:make-frame-prop-name :data "ENVIRONMENT")
,@(il:for il:aspect il:in
`((,(and il:environment (il:environment-vars il:environment))
"vars")
(,(and il:environment (il:environment-functions il:environment))
"functions")
(,(and il:environment (il:environment-blocks il:environment))
"blocks")
(,(and il:environment (il:environment-tagbodies il:environment))
"tag bodies"))
il:bind il:group-name il:p-list
il:eachtime (il:setq il:group-name (cadr il:aspect))
(il:setq il:p-list (car il:aspect))
il:when (not (null il:p-list))
il:join
`(,(il:make-frame-prop-name :data il:group-name)
,@(il:for il:p il:on il:p-list il:by cddr il:collect
(il:make-frame-prop-name :label-fn
(il:function (il:lambda (il:prop-name il:framespec)
(car (il:frame-prop-name-data il:prop-name))))
:value-fn
(il:function (il:lambda (il:prop-name il:framespec)
(cadr (il:frame-prop-name-data il:prop-name))))
:setf-fn
(il:function (il:lambda (il:prop-name il:framespec il:new-value)
(il:change (cadr (il:frame-prop-name-data
il:prop-name))
il:new-value)))
:data il:p))))))
il:else
(flet ((il:build-name (&key il:arg-name il:arg-number)
(il:make-frame-prop-name :label-fn
(il:function (il:lambda (il:prop-name il:framespec)
(car (il:frame-prop-name-data il:prop-name))))
:value-fn
(il:function (il:lambda (il:prop-name il:framespec)
(il:stkarg (cadr (il:frame-prop-name-data
il:prop-name))
(car il:framespec))))
:setf-fn
(il:function (il:lambda (il:prop-name il:framespec il:new-value)
(il:setstkarg (cadr (il:frame-prop-name-data
il:prop-name))
(car il:framespec)
il:new-value)))
:data
(list il:arg-name il:arg-number))))
(let ((il:nargs (il:stknargs il:pos t))
(il:nargs1 (il:stknargs il:pos))
(il:fnname (il:stkname il:pos))
il:argname
(il:arglist))
(and (il:litatom il:fnname)
(il:ccodep il:fnname)
(il:setq il:arglist (il:listp (il:smartarglist il:fnname))))
`(,(il:make-frame-prop-name :inspect-fn
(il:function (il:lambda (il:value il:prop-name il:framespec
il:window)
(il:inspect/as/function il:value
(car il:framespec)
il:window)))
:data
(il:fetch (il:bkmenuitem il:frame-name) il:of il:backtrace-item))
,@(il:bind il:mode il:for il:i il:from 1 il:to il:nargs1 il:collect
(progn (il:while (il:fmemb (il:setq il:argname (il:pop il:arglist))
lambda-list-keywords)
il:do
(il:setq il:mode il:argname))
(il:build-name :arg-name
(or (il:stkargname il:i il:pos)
; special
(if (case il:mode
((nil &optional) il:argname)
(t nil))
(string il:argname)
(il:concat "arg " (- il:i 1))))
:arg-number il:i)))
,@(let* ((il:novalue "No value")
(il:slots (il:for il:pvar il:from 0 il:as il:i il:from
(il:add1 il:nargs1)
il:to il:nargs il:by 1 il:when
(and (il:neq il:novalue (il:stkarg il:i il:pos
il:novalue))
(or (il:setq il:argname (il:stkargname
il:i il:pos))
(il:setq il:argname (il:concat
"local "
il:pvar)))
)
il:collect
(il:build-name :arg-name il:argname
:arg-number il:i))))
(and il:slots (cons (il:make-frame-prop-name :data "locals")
il:slots)))))))))
(defun il:debugger-stack-frame-fetchfn (il:framespec il:prop-name)
(il:apply* (il:frame-prop-name-value-fn il:prop-name)
il:prop-name il:framespec))
(defun il:debugger-stack-frame-storefn (il:framespec il:prop-name il:newvalue)
(il:apply* (il:frame-prop-name-setf-fn il:prop-name)
il:prop-name il:framespec il:newvalue))
(defun il:debugger-stack-frame-value-command (il:datum il:prop-name
il:framespec il:window)
(il:apply* (il:frame-prop-name-inspect-fn il:prop-name)
il:datum il:prop-name il:framespec il:window))
(defun il:debugger-stack-frame-title (il:framespec &optional il:window)
(declare (ignore il:window))
(il:concat (il:stkname (car il:framespec)) " Frame"))
(defun il:debugger-stack-frame-property (il:prop-name il:framespec)
(il:apply* (il:frame-prop-name-label-fn il:prop-name)
il:prop-name il:framespec))
;; Teaching the debugger that there are other file-manager types that can
;; appear on the stack
(defvar xcl::*function-types* '(il:fns il:functions)
"Manager types that can appear on the stack")
;; Redefine a couple of system functions to use the above stuff
#+Xerox-Lyric
(progn
(defun il:attach-backtrace-menu (&optional (il:ttywindow
(il:wfromds (il:ttydisplaystream)))
il:skip)
(let ((il:bkmenu (il:|create| il:menu
il:items il:_
(il:collect-backtrace-items il:ttywindow il:skip)
il:whenselectedfn il:_
(il:function il:backtrace-item-selected)
il:whenheldfn il:_
#'(il:lambda (il:item il:menu il:button)
(declare (ignore il:item il:menu))
(case il:button
(il:left (il:promptprint
"Open a frame inspector on this stack frame"
))
(il:middle (il:promptprint
"Inspect/Edit this function"))
))
il:menuoutlinesize il:_ 0
il:menufont il:_ il:backtracefont
il:menucolumns il:_ 1))
(il:ttyregion (il:windowprop il:ttywindow 'il:region))
il:btw)
(cond
((il:setq il:btw (il:|for| il:atw il:|in| (il:attachedwindows il:ttywindow)
il:|when| (and (il:setq il:btw (il:windowprop il:atw 'il:menu))
(eql (il:|fetch| (il:menu il:whenselectedfn)
il:|of| (car il:btw))
(il:function il:backtrace-item-selected)))
il:|do|
(return il:atw)))
(il:deletemenu (car (il:windowprop il:btw 'il:menu))
nil il:btw)
(il:windowprop il:btw 'il:extent nil)
(il:clearw il:btw))
((il:setq il:btw (il:createw (il:region-next-to (il:windowprop il:ttywindow 'il:region)
(il:widthifwindow (il:imin (il:|fetch| (il:menu
il:imagewidth
)
il:|of| il:bkmenu)
il:|MaxBkMenuWidth|))
(il:|fetch| (il:region il:height) il:|of| il:ttyregion
)
'il:left)))
(il:attachwindow il:btw il:ttywindow (cond
((il:igreaterp (il:|fetch| (il:region il:left)
il:|of| (il:windowprop
il:btw
'il:region))
(il:|fetch| (il:region il:left)
il:|of| il:ttyregion))
'il:right)
(t 'il:left))
nil
'il:localclose)
(il:windowprop il:btw 'il:process (il:windowprop il:ttywindow 'il:process))
))
(il:addmenu il:bkmenu il:btw (il:|create| il:_ il:position
il:xcoord il:_ 0
il:ycoord il:_ (il:idifference (il:windowprop
il:btw
'il:height)
(il:|fetch| (il:menu il:imageheight
) il:|of|
il:bkmenu
))))))
(defun il:backtrace-item-selected (il:item il:menu il:button)
(il:resetlst
(prog (il:olditem il:ttywindow il:bkpos il:pos il:positions il:framewindow
(il:framespecn (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| il:item)
))
(cond
((il:setq il:olditem (il:|fetch| (il:menu il:menuuserdata) il:|of| il:menu))
(il:menudeselect il:olditem il:menu)
))
(il:setq il:ttywindow (il:windowprop (il:wfrommenu il:menu)
'il:mainwindow))
(il:setq il:bkpos (il:windowprop il:ttywindow 'il:stack-position))
(il:setq il:pos (il:stknth (- il:framespecn)
il:bkpos))
(let ((il:lp (il:windowprop il:ttywindow 'il:lastpos)))
(and il:lp (il:stknth 0 il:pos il:lp)))
(il:menuselect il:item il:menu)
(if (eq il:button 'il:middle)
(progn
(il:resetsave nil (list 'il:relstk il:pos))
(il:inspect/as/function (il:|fetch| (il:bkmenuitem il:frame-name)
il:|of| il:item)
il:pos il:ttywindow))
(progn
(il:setq il:framewindow
(xcl:with-profile (il:process.eval
(il:windowprop il:ttywindow 'il:process)
'(let ((il:profile (xcl:copy-profile (xcl:find-profile
"READ-PRINT"))))
(setf (xcl::profile-entry-value '
xcl:*eval-function* il:profile)
xcl:*eval-function*)
(xcl:save-profile il:profile))
t)
(il:inspectw.create (list il:pos il:item)
'il:debugger-stack-frame-prop-names
'il:debugger-stack-frame-fetchfn
'il:debugger-stack-frame-storefn nil '
il:debugger-stack-frame-value-command nil '
il:debugger-stack-frame-title nil (
il:make-frame-inspect-window
il:ttywindow)
'il:debugger-stack-frame-property)))
(cond
((not (il:windowprop il:framewindow 'il:mainwindow))
(il:attachwindow il:framewindow il:ttywindow
(cond
((il:igreaterp (il:|fetch| (il:region il:bottom)
il:|of| (il:windowprop il:framewindow
'il:region))
(il:|fetch| (il:region il:bottom)
il:|of| (il:windowprop il:ttywindow 'il:region)))
'il:top)
(t 'il:bottom))
nil
'il:localclose)
(il:windowaddprop il:framewindow 'il:closefn (il:function il:detachwindow
))))))
(return))))
(defun il:collect-backtrace-items (xcl::tty-window xcl::skip)
(let* ((xcl::items (cons nil nil))
(xcl::items-tail xcl::items))
(macrolet ((xcl::collect-item (xcl::new-item)
`(progn (setf (rest xcl::items-tail)
(cons ,xcl::new-item nil))
(pop xcl::items-tail))))
(let* ((xcl::filter-fn (cond
((null xcl::skip)
#'xcl:true)
((eq xcl::skip t)
il:*short-backtrace-filter*)
(t xcl::skip)))
(xcl::top-frame (il:stknth 0 (il:getwindowprop xcl::tty-window '
il:stack-position)))
(xcl::next-frame xcl::top-frame)
(xcl::frame-number 0)
xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label)
(loop (when (null xcl::next-frame)
(return))
(multiple-value-setq (xcl::interesting-p xcl::last-frame-consumed
xcl::use-frame xcl::label)
(funcall xcl::filter-fn xcl::next-frame))
(when (null xcl::last-frame-consumed)
(setf xcl::last-frame-consumed xcl::next-frame))
(when xcl::interesting-p
(when (null xcl::use-frame)
(setf xcl::use-frame xcl::last-frame-consumed))
(when (null xcl::label)
(setf xcl::label (il:stkname xcl::use-frame))
(if (member xcl::label '(eval il:eval il:apply apply)
:test
'eq)
(setf xcl::label (il:stkarg 1 xcl::use-frame))))
(loop (cond
((not (typep xcl::next-frame 'il:stackp))
(error "~%Use-frame ~S not found" xcl::use-frame))
((xcl::stack-eql xcl::next-frame xcl::use-frame)
(return))
(t (incf xcl::frame-number)
(setf xcl::next-frame (il:stknth -1 xcl::next-frame
xcl::next-frame)))))
(xcl::collect-item (il:|create| il:bkmenuitem
il:label il:_ (let ((*print-level* 2)
(*print-length* 3)
(*print-escape* t)
(*print-gensym* t)
(*print-pretty* nil)
(*print-circle* nil)
(*print-radix* 10)
(*print-array* nil)
(il:*print-structure*
nil))
(prin1-to-string
xcl::label))
il:bkmenuinfo il:_ xcl::frame-number
il:frame-name il:_ xcl::label)))
(loop (cond
((not (typep xcl::next-frame 'il:stackp))
(error "~%Last-frame-consumed ~S not found"
xcl::last-frame-consumed))
((prog1 (xcl::stack-eql xcl::next-frame xcl::last-frame-consumed
)
(incf xcl::frame-number)
(setf xcl::next-frame (il:stknth -1 xcl::next-frame
xcl::next-frame)))
(return)))))))
(rest xcl::items)))
)
#+Xerox-Medley
(progn
(defun dbg::attach-backtrace-menu (&optional tty-window skip)
(declare (special il:\\term.ofd il:backtracefont))
(or tty-window (il:setq tty-window (il:wfromds (il:ttydisplaystream))))
(prog (btw bkmenu
(tty-region (il:windowprop tty-window 'il:region))
;; And, for the FORMAT below...
(*print-level* 2)
(*print-length* 3)
(*print-escape* t)
(*print-gensym* t)
(*print-pretty* nil)
(*print-circle* nil)
(*print-radix* 10)
(*print-array* nil)
(il:*print-structure* nil))
(setq bkmenu
(il:|create| il:menu
il:items il:_ (dbg::collect-backtrace-items tty-window skip)
il:whenselectedfn il:_ 'dbg::backtrace-item-selected
il:menuoutlinesize il:_ 0
il:menufont il:_ il:backtracefont
il:menucolumns il:_ 1
il:whenheldfn il:_
#'(il:lambda (item menu button)
(declare (ignore item menu))
(case button
(il:left
(il:promptprint
"Open a frame inspector on this stack frame"))
(il:middle
(il:promptprint "Inspect/Edit this function"))))))
(cond ((setq btw
(dolist (atw (il:attachedwindows tty-window))
;; Test for an attached window that has a backtrace menu in
;; it.
(when (and (setq btw (il:windowprop atw 'il:menu))
(eq (il:|fetch| (il:menu il:whenselectedfn)
il:|of| (car btw))
'dbg::backtrace-item-selected))
(return atw))))
;; If there is alread a backtrace window, delete the old menu from
;; it.
(il:deletemenu (car (il:windowprop btw 'il:menu)) nil btw)
(il:windowprop btw 'il:extent nil)
(il:clearw btw))
((setq btw
(il:createw (dbg::region-next-to
(il:windowprop tty-window 'il:region)
(il:widthifwindow
(il:imin (il:|fetch| (il:menu il:imagewidth)
il:|of| bkmenu)
il:|MaxBkMenuWidth|))
(il:|fetch| (il:region il:height)
il:|of| tty-region)
:left)))
; put bt window at left of TTY
; window unless ttywindow is
; near left edge.
(il:attachwindow btw tty-window
(if (il:igreaterp (il:|fetch| (il:region il:left)
il:|of|
(il:windowprop btw
'il:region))
(il:|fetch| (il:region il:left)
il:|of| tty-region))
'il:right
'il:left)
nil
'il:localclose)
;; So that button clicks will switch the TTY
(il:windowprop btw 'il:process
(il:windowprop tty-window 'il:process))))
(il:addmenu bkmenu btw (il:|create| il:position
il:xcoord il:_ 0
il:ycoord il:_ (- (il:windowprop btw 'il:height)
(il:|fetch| (il:menu
il:imageheight)
il:|of| bkmenu))))
;; IL:ADDMENU sets up buttoneventfn for window that we don't
;; want. We want to catch middle button events before the menu
;; handler, so that we can pop up edit/inspect menu for the frame
;; currently selected. So replace the buttoneventfn, and can
;; nuke the cursorin and cursormoved guys, cause don't need them.
(il:windowprop btw 'il:buttoneventfn 'dbg::backtrace-menu-buttoneventfn)
(il:windowprop btw 'il:cursorinfn nil)
(il:windowprop btw 'il:cursormovedfn nil)))
(defun dbg::collect-backtrace-items (tty-window skip)
(xcl:with-collection
;;
;; There are a number of possibilities for the values returned by the
;; filter-fn.
;;
;; (1) INTERESTING-P is false, and the other values are all NIL. This
;; is the simple case where the stack frame NEXT-POS should be ignored
;; completly, and processing should continue with the next frame.
;;
;; (2) INTERESTING-P is true, and the other values are all NIL. This
;; is the simple case where the stack frame NEXT-POS should appear in
;; the backtrace as is, and processing should continue with the next
;; frame.
;;
;; [Note that these two cases take care of old values of the
;; filter-fn.]
;;
;; (3) INTERESTING-P is false, and LAST-FRAME-CONSUMED is a stack
;; frame. In that case, ignore all stack frames from NEXT-POS to
;; LAST-FRAME-CONSUMED, inclusive.
;;
;; (4) INTERESTING-P is true, and LAST-FRAME-CONSUMED is a stack
;; frame. In this case, the backtrace should include a single entry
;; coresponding to the frame USE-FRAME (which defaults to
;; LAST-FRAME-CONSUMED), and processing should continue with the next
;; frame after LAST-FRAME-CONSUMED. If LABEL is non-NIL, it will be
;; the label that appears in the backtrace menu; otherwise the name of
;; USE-FRAME will be used (or the form being EVALed if the frame is an
;; EVAL frame).
;;
(let* ((filter (cond ((null skip) #'xcl:true)
((eq skip t) il:*short-backtrace-filter*)
(t skip)))
(top-frame (il:stknth 0 (il:getwindowprop tty-window
'dbg::stack-position)))
(next-frame top-frame)
(frame-number 0)
interestingp last-frame-consumed frame-to-use label-to-use)
(loop (when (null next-frame) (return))
;; Get the values of INTERSTINGP, LAST-FRAME-CONSUMED,
;; FRAME-TO-USE, and LABEL-TO-USE
(multiple-value-setq (interestingp last-frame-consumed
frame-to-use label-to-use)
(funcall filter next-frame))
(when (null last-frame-consumed)
(setf last-frame-consumed next-frame))
(when interestingp
(when (null frame-to-use)
(setf frame-to-use last-frame-consumed))
(when (null label-to-use)
(setf label-to-use (il:stkname frame-to-use))
(if (member label-to-use '(eval il:eval il:apply apply)
:test 'eq)
(setf label-to-use (il:stkarg 1 frame-to-use))))
;; Walk the stack until we find the frame to use
(loop (cond ((not (typep next-frame 'il:stackp))
(error "~%Use-frame ~S not found" frame-to-use))
((xcl::stack-eql next-frame frame-to-use)
(return))
(t (incf frame-number)
(setf next-frame
(il:stknth -1 next-frame next-frame)))))
;; Add the menu item to the list under construction
(xcl:collect (il:|create| il:bkmenuitem
il:label il:_ (let ((*print-level* 2)
(*print-length* 3)
(*print-escape* t)
(*print-gensym* t)
(*print-pretty* nil)
(*print-circle* nil)
(*print-radix* 10)
(*print-array* nil)
(il:*print-structure* nil))
(prin1-to-string label-to-use))
il:bkmenuinfo il:_ frame-number
il:frame-name il:_ label-to-use)))
;; Update NEXT-POS
(loop (cond ((not (typep next-frame 'il:stackp))
(error "~%Last-frame-consumed ~S not found"
last-frame-consumed))
((prog1
(xcl::stack-eql next-frame last-frame-consumed)
(incf frame-number)
(setf next-frame (il:stknth -1 next-frame
next-frame)))
(return))))))))
(defun dbg::backtrace-menu-buttoneventfn (window &aux menu)
(setq menu (car (il:listp (il:windowprop window 'il:menu))))
(unless (or (il:lastmousestate il:up) (null menu))
(il:totopw window)
(cond ((il:lastmousestate il:middle)
;; look for a selected frame in this menu, and then pop up
;; the editor invoke menu for that frame. don't change the
;; selection, just present the edit menu.
(let* ((selection (il:menu.handler menu
(il:windowprop window 'il:dsp)))
(tty-window (il:windowprop window 'il:mainwindow))
(last-pos (il:windowprop tty-window 'dbg::lastpos)))
;; don't have to worry about releasing POS because we
;; only look at it here (nobody here hangs on to it)
;; and we will be around for less time than LASTPOS.
;; The debugger is responsible for releasing LASTPOS.
(il:inspect/as/function (cond
((and selection
(il:|fetch| (il:bkmenuitem il:frame-name)
il:|of| (car selection))))
((and (symbolp (il:stkname last-pos))
(il:getd (il:stkname last-pos)))
(il:stkname last-pos))
(t 'il:nill))
last-pos tty-window)))
(t (let ((selection (il:menu.handler menu
(il:windowprop window 'il:dsp))))
(when selection
(il:doselecteditem menu (car selection) (cdr selection))))))))
;; This function isn't really redefined, but it needs to be recomiled since we
;; changed the def'n of the BKMENUITEM record.
(defun dbg::backtrace-item-selected (item menu button)
;;When a frame name is selected in the backtrace menu, this is the function
;;that gets called.
(declare (special il:brkenv) (ignore button))
(let* ((frame-spec (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| item))
(tty-window (il:windowprop (il:wfrommenu menu) 'il:mainwindow))
(bkpos (il:windowprop tty-window 'dbg::stack-position))
(pos (il:stknth (- frame-spec) bkpos)))
(let ((lp (il:windowprop tty-window 'dbg::lastpos)))
(and lp (il:stknth 0 pos lp)))
;; change the item selected from OLDITEM to ITEM. Only do this on left
;; buttons now. Middle just pops up the edit menu, doesn't select. -woz
(let ((old-item (il:|fetch| (il:menu il:menuuserdata) il:|of| menu)))
(when old-item (il:menudeselect old-item menu))
(il:menuselect item menu))
;; Change the lexical environment so it is the one in effect as of this
;; frame.
(il:process.eval (il:windowprop tty-window (quote dbg::process))
`(setq il:brkenv ',(il:find-lexical-environment pos))
t)
(let ((frame-window (xcl:with-profile
(il:process.eval (il:windowprop tty-window
'il:process)
`(let ((profile (xcl:copy-profile
(xcl:find-profile
"READ-PRINT"))))
(setf
(xcl::profile-entry-value
'xcl:*eval-function* profile)
xcl:*eval-function*)
(xcl:save-profile profile))
t)
(il:inspectw.create pos
#'(lambda (pos)
(dbg::stack-frame-properties pos t))
'dbg::stack-frame-fetchfn
'dbg::stack-frame-storefn
nil
'dbg::stack-frame-value-command
nil
(format nil "~S Frame" (il:stkname pos))
nil (dbg::make-frame-inspect-window
tty-window)
'dbg::stack-frame-property))))
(when (not (il:windowprop frame-window 'il:mainwindow))
(il:attachwindow frame-window tty-window
(if (> (il:|fetch| (il:region il:bottom) il:|of|
(il:windowprop frame-window 'il:region))
(il:|fetch| (il:region il:bottom) il:|of|
(il:windowprop tty-window 'il:region)))
'il:top 'il:bottom)
nil 'il:localclose)
(il:windowaddprop frame-window 'il:closefn 'il:detachwindow)))))
) ;end of Xerox-Medley
(defun il:select.fns.editor (&optional function)
;; gives the user a menu choice of editors.
(il:menu (il:|create| il:menu
il:items il:_ (cond ((il:ccodep function)
'((il:|InspectCode| 'il:inspectcode
"Shows the compiled code.")
(il:|DisplayEdit| 'ed
"Edit it with the display editor")
(il:|TtyEdit| 'il:ef
"Edit it with the standard editor")))
((il:closure-p function)
'((il:|Inspect| 'inspect
"Inspect this object")))
(t '((il:|DisplayEdit| 'ed
"Edit it with the display editor")
(il:|TtyEdit| 'il:ef
"Edit it with the standard editor"))))
il:centerflg il:_ t)))
;;
;; PCL specific extensions to the debugger
;; There are some new things that act as functions, and that we want to be
;; able to edit from a backtrace window
(pushnew 'methods xcl::*function-types*)
(eval-when (eval compile load)
(unless (generic-function-p (symbol-function 'il:inspect/as/function))
(make-specializable 'il:inspect/as/function)))
(defmethod il:inspect/as/function (name stack-pointer debugger-window)
;; Calls an editor on function NAME. STKP and WINDOW are the stack pointer
;; and window of the break in which this inspect command was called.
(declare (ignore debugger-window))
(let ((editor (il:select.fns.editor name)))
(case editor
((nil)
;; No editor chosen, so don't do anything
nil)
(il:inspectcode
;; Inspect the compiled code
(let ((frame (xcl::stack-pointer-frame stack-pointer)))
(if (and (il:stackp stack-pointer)
(xcl::stack-frame-valid-p frame))
(il:inspectcode (let ((code-base (xcl::stack-frame-fn-header frame)))
(cond ((eq (il:\\get-compiled-code-base name)
code-base)
name)
(t
;; Function executing in this frame is not
;; the one in the definition cell of its
;; name, so fetch the real code. Have to
;; pass a CCODEP
(il:make-compiled-closure code-base))))
nil nil nil (xcl::stack-frame-pc frame))
(il:inspectcode name))))
(ed
;; Use the standard editor.
;; This used to take care to apply the editor in the debugger
;; process, so forms evaluated in the editor happen in the
;; context of the break. But that doesn't count for much any
;; more, now that lexical variables are the way to go. Better to
;; use the LEX debugger command (thank you, Herbie) and
;; shift-select pieces of code from the editor into the debugger
;; window.
(ed name `(,@xcl::*function-types* :display)))
(otherwise (funcall editor name)))))
(defmethod il:inspect/as/function ((name standard-object) stkp window)
(when (il:menu (il:|create| il:menu
il:items il:_ '(("Inspect" t "Inspect this object"))))
(inspect name)))
(defmethod il:inspect/as/function ((x standard-method) stkp window)
(let* ((generic-function-name (slot-value (slot-value x 'generic-function)
'name))
(method-name (full-method-name x))
(editor (il:select.fns.editor method-name)))
(il:allow.button.events)
(case editor
(ed (ed method-name '(:display methods)))
(il:inspectcode (il:inspectcode (slot-value x 'function)))
((nil) nil)
(otherwise (funcall editor method-name)))))
;; A replacement for the vanilla IL:INTERESTING-FRAME-P so we can see methods
;; and generic-functions on the stack.
(defun interesting-frame-p (stack-pos &optional interp-flag)
;; Return up to four values: INTERESTING-P LAST-FRAME-CONSUMED USE-FRAME and
;; LABEL. See the function IL:COLLECT-BACKTRACE-ITEMS for a full description
;; of how these values are used.
(labels
((function-matches-frame-p (function frame)
"Is the function being called in this frame?"
(let* ((frame-name (il:stkname frame))
(code-being-run (cond
((typep frame-name 'il:closure)
frame-name)
((and (consp frame-name)
(eq 'il:\\interpreter
(xcl::stack-frame-name
(il:\\stackargptr frame))))
frame-name)
(t (xcl::stack-frame-fn-header
(il:\\stackargptr frame))))))
(or (eq function code-being-run)
(and (typep function 'il:compiled-closure)
(eq (xcl::compiled-closure-fnheader function)
code-being-run)))))
(generic-function-from-frame (frame)
"If this the frame of a generic function return the gf, otherwise
return NIL."
;; Generic functions are implemented as compiled closures. On the
;; stack, we only see the fnheader for the the closure. This could
;; be a discriminator code, or in the default method only case it
;; will be the actual method function. To tell if this is a generic
;; function frame, we have to check very carefully to see if the
;; right stuff is on the stack. Specifically, the closure's ccode,
;; and the first local variable has to be a ptrhunk big enough to be
;; a FIN environment, and fin-env-fin of that ptrhunk has to point
;; to a generic function whose ccode and environment match.
(let ((n-args (il:stknargs frame))
(env nil)
(gf nil))
(if (and ;; is there at least one local?
(> (il:stknargs frame t) n-args)
;; and does the local contain something that might be
;; the closure environment of a funcallable instance?
(setf env (il:stkarg (1+ n-args) frame))
;; and does the local contain something that might be
;; the closure environment of a funcallable instance?
(typep env *fin-env-type*)
(setf gf (fin-env-fin env))
;; whose fin-env-fin points to a generic function?
(generic-function-p gf)
;; whose environment is the same as env?
(eq (xcl::compiled-closure-env gf) env)
;; and whose code is the same as the code for this
;; frame?
(function-matches-frame-p gf frame))
gf
nil))))
(let ((frame-name (il:stkname stack-pos)))
;; See if there is a generic-function on the stack at this
;; location.
(let ((gf (generic-function-from-frame stack-pos)))
(when gf
(return-from interesting-frame-p (values t stack-pos stack-pos gf))))
;; See if this is an interpreted method. The method body is
;; wrapped in a (BLOCK <function-name> ...). We look for an
;; interpreted call to BLOCK whose block-name is the name of
;; generic-function.
(when (and (eq frame-name 'eval)
(consp (il:stkarg 1 stack-pos))
(eq (first (il:stkarg 1 stack-pos)) 'block)
(symbolp (second (il:stkarg 1 stack-pos)))
(fboundp (second (il:stkarg 1 stack-pos)))
(generic-function-p
(symbol-function (second (il:stkarg 1 stack-pos)))))
(let* ((form (il:stkarg 1 stack-pos))
(block-name (second form))
(generic-function (symbol-function block-name))
(methods (generic-function-methods (symbol-function block-name))))
;; If this is really a method being called from a
;; generic-function, the g-f should be no more than a
;; few(?) frames up the stack. Check for the method call
;; by looking for a call to APPLY, where the function
;; being applied is the code in one of the methods.
(do ((i 100 (1- i))
(previous-pos stack-pos current-pos)
(current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos))
(found-method nil)
(method-pos))
((or (null current-pos) (<= i 0)) nil)
(cond ((equalp generic-function
(generic-function-from-frame current-pos))
(if found-method
(return-from interesting-frame-p
(values t previous-pos method-pos found-method))
(return)))
(found-method nil)
((eq (il:stkname current-pos) 'apply)
(dolist (method methods)
(when (memq (il:stkarg 1 current-pos)
(method-cached-functions method))
(setq method-pos current-pos)
(setq found-method method)
(return))))))))
;; Try to handle compiled methods
(when (and (symbolp frame-name)
(not (fboundp frame-name))
(eq (il:chcon1 frame-name)
(il:charcode il:\())
(or (string-equal "(method " (symbol-name frame-name)
:start2 0 :end2 13)
(string-equal "(method " (symbol-name frame-name)
:start2 0 :end2 12)
(string-equal "(method " (symbol-name frame-name)
:start2 0 :end2 8)))
;; Looks like a name that PCL consed up. See if there is a
;; GF nearby up the stack. If there is, use it to help
;; determine which method we have.
(do ((i 30 (1- i))
(current-pos (il:stknth -1 stack-pos)
(il:stknth -1 current-pos))
(gf))
((or (null current-pos)
(<= i 0))
nil)
(setq gf (generic-function-from-frame current-pos))
(when gf
(dolist (method (generic-function-methods gf))
(dolist (function (method-cached-functions method))
(when (function-matches-frame-p function stack-pos)
(return-from interesting-frame-p
(values t stack-pos stack-pos method)))))
(return))))
;; If we haven't already returned, use the default method.
(xcl::interesting-frame-p stack-pos interp-flag))))
(setq il:*short-backtrace-filter* 'interesting-frame-p)
;;; Support for undo
(defun undoable-setf-slot-value (object slot-name new-value)
(if (slot-boundp object slot-name)
(il:undosave (list 'undoable-setf-slot-value
object slot-name (slot-value object slot-name)))
(il:undosave (list 'slot-makunbound object slot-name)))
(setf (slot-value object slot-name) new-value))
(setf (get 'slot-value :undoable-setf-inverse) 'undoable-setf-slot-value)
;;; Support for ?= and friends
;; The arglists for generic-functions are built using gensyms, and don't reflect
;; any keywords (they are all included in an &REST arg). Rather then use the
;; arglist in the code, we use the one that PCL kindly keeps in the generic-function.
(xcl:advise-function 'il:smartarglist
'(if (and il:explainflg
(symbolp il:fn)
(fboundp il:fn)
(generic-function-p (symbol-function il:fn)))
(generic-function-pretty-arglist (symbol-function il:fn))
(xcl:inner))
:when :around :priority :last)
(setf (get 'defclass 'il:argnames)
'(nil (class-name (#\{ superclass-name #\} #\*)
(#\{ slot-specifier #\} #\*)
#\{ slot-option #\} #\*)))
(setf (get 'defmethod 'il:argnames)
'(nil (#\{ name #\| (setf name) #\} #\{ method-qualifier #\} #\*
specialized-lambda-list #\{ declaration #\| doc-string #\} #\*
#\{ form #\} #\*)))
;;; Prettyprinting support, the result of Harley Davis.
;; Support the standard Prettyprinter. This is really minimal right now. If
;; anybody wants to fix this, I'd be happy to include their code. In fact,
;; there is almost no support for Commonlisp in the standard Prettyprinter, so
;; the field is wide open to hackers with time on their hands.
(setf (get 'defmethod :definition-print-template) ;Not quite right, since it
'(:name :arglist :body)) ; doesn't handle qualifiers,
; but it will have to do.
(defun defclass-prettyprint (form)
(let ((left (il:dspxposition))
(char-width (il:charwidth (il:charcode x) *standard-output*)))
(xcl:destructuring-bind (defclass name supers slots . options) form
(princ "(")
(prin1 defclass)
(princ " ")
(prin1 name)
(princ " ")
(if (null supers)
(princ "()") ;Print "()" instead of "nil"
(il:sequential.prettyprint (list supers) (il:dspxposition)))
(if (null slots)
(progn (il:prinendline (+ left (* 4 char-width)) *standard-output*)
(princ "()"))
(il:sequential.prettyprint (list slots) (+ left (* 4 char-width))))
(when options
(il:sequential.prettyprint options (+ left (* 2 char-width))))
(princ ")")
nil)))
(let ((pprint-macro (assoc 'defclass il:prettyprintmacros)))
(if (null pprint-macro)
(push (cons 'defclass 'defclass-prettyprint)
il:prettyprintmacros)
(setf (cdr pprint-macro) 'defclass-prettyprint)))
(defun binder-prettyprint (form)
;; Prettyprints expressions like MULTIPLE-VALUE-BIND and WITH-SLOTS
;; that are of the form (fn (var ...) form &rest body).
;; This code is far from correct, but it's better than nothing.
(if (and (consp form)
(not (null (cdddr form))))
;; I have no idea what I'm doing here. Seems I can copy and edit somebody
;; elses code without understanding it.
(let ((body-indent (+ (il:dspxposition)
(* 2 (il:charwidth (il:charcode x)
*standard-output*))))
(form-indent (+ (il:dspxposition)
(* 4 (il:charwidth (il:charcode x)
*standard-output*)))))
(princ "(")
(prin1 (first form))
(princ " ")
(il:superprint (second form) form nil *standard-output*)
(il:sequential.prettyprint (list (third form)) form-indent)
(il:sequential.prettyprint (cdddr form) body-indent)
(princ ")")
nil) ;Return NIL to indicate that we did
; the printing
t)) ;Return true to use default printing
(dolist (fn '(multiple-value-bind with-accessors with-slots))
(let ((pprint-macro (assoc fn 'il:prettyprintmacros)))
(if (null pprint-macro)
(push (cons fn 'binder-prettyprint)
il:prettyprintmacros)
(setf (cdr pprint-macro) 'binder-prettyprint))))
;; SEdit has its own prettyprinter, so we need to support that too. This is due
;; to Harley Davis. Really.
(push (cons :slot-spec
'(((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
break sedit::from-indent . 0)
(sedit::set-indent . 1)
(sedit::next-inline? 1 break sedit::from-indent . 1)
(sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
break sedit::from-indent . 0))
((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
break sedit::from-indent . 0)
(sedit::set-indent . 1)
(sedit::next-inline? 1 break sedit::from-indent . 1)
(sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1)
break sedit::from-indent . 0))))
sedit:*indent-alist*)
(setf (sedit:get-format :slot-spec)
'(:indent :slot-spec :inline t))
(setf (sedit:get-format :slot-spec-list)
'(:indent :binding-list :args (:slot-spec) :inline nil))
(setf (sedit:get-format 'defclass)
'(:indent ((2) 1)
:args (:keyword nil nil :slot-spec-list nil)
:sublists (4)))
(setf (sedit:get-format 'defmethod)
'(:indent ((2))
:args (:keyword nil :lambda-list nil)
:sublists (3)))
(setf (sedit:get-format 'defgeneric) 'defun)
(setf (sedit:get-format 'generic-flet) 'flet)
(setf (sedit:get-format 'generic-labels) 'flet)
(setf (sedit:get-format 'call-next-method)
'(:indent (1) :args (:keyword nil)))
(setf (sedit:get-format 'symbol-macrolet) 'let)
(setf (sedit:get-format 'with-accessors)
'(:indent ((1) 1)
:args (:keyword :binding-list nil)
:sublists (2)
:miser :never))
(setf (sedit:get-format 'with-slots) 'with-accessors)
(setf (sedit:get-format 'make-instance)
'(:indent ((1))
:args (:keyword nil :slot-spec-list)))
(setf (sedit:get-format '*make-instance) 'make-instance)
;;; PrettyFileIndex stuff, the product of Harley Davis.
(defvar *pfi-class-type* '(class defclass pfi-class-namer))
(defvar *pfi-method-type* '(method defmethod pfi-method-namer)
"Handles method for prettyfileindex")
(defvar *pfi-index-accessors* nil
"t -> each slot accessor gets a listing in the index.")
(defvar *pfi-method-index* :group
":group, :separate, :both, or nil")
(defun pfi-add-class-type ()
(pushnew *pfi-class-type* il:*pfi-types*))
(defun pfi-add-method-type ()
(pushnew *pfi-method-type* il:*pfi-types*))
(defun pfi-class-namer (expression entry)
(let ((class-name (second expression)))
;; Following adds all slot readers/writers/accessors as separate entries in
;; the index. Probably a mistake.
(if *pfi-index-accessors*
(let ((slot-list (fourth expression))
(accessor-names nil))
(labels ((add-accessor (method-index name-index)
(push (case *pfi-method-index*
(:group method-index)
(:separate name-index)
((t :both) (list method-index name-index))
((nil) nil)
(otherwise (error "Illegal value for *pfi-method-index*: ~S"
*pfi-method-index*)))
accessor-names))
(add-reader (reader-name)
(add-accessor `(method (,reader-name (,class-name)))
`(,reader-name (,class-name))))
(add-writer (writer-name)
(add-accessor `(method ((setf ,writer-name) (t ,class-name)))
`((setf ,writer-name) (t ,class-name)))))
(dolist (slot-def slot-list)
(do* ((rest-slot-args (cdr slot-def) (cddr rest-slot-args))
(slot-arg (first rest-slot-args) (first rest-slot-args)))
((null rest-slot-args))
(case slot-arg
(:reader (add-reader (second rest-slot-args)))
(:writer (add-writer (second rest-slot-args)))
(:accessor (add-reader (second rest-slot-args))
(add-writer (second rest-slot-args)))
(otherwise nil))))
(cons `(class (,class-name)) accessor-names)))
class-name)))
(defun pfi-method-namer (expression entry)
(let ((method-name (second expression))
(specializers nil)
(qualifiers nil)
lambda-list)
(do* ((rest-qualifiers (cddr expression) (cdr rest-qualifiers))
(qualifier (first rest-qualifiers) (first rest-qualifiers)))
((listp qualifier) (setq lambda-list qualifier)
(setq qualifiers (reverse qualifiers)) qualifiers)
(push qualifier qualifiers))
(do* ((rest-lambda-list lambda-list (cdr rest-lambda-list))
(arg (first rest-lambda-list) (first rest-lambda-list)))
((or (member arg lambda-list-keywords) (null rest-lambda-list))
(setq specializers (reverse specializers)))
(push (if (listp arg) (second arg) t) specializers))
(let ((method-index `(method (,method-name ,@qualifiers ,specializers)))
(name-index `(,method-name ,@qualifiers ,specializers)))
(case *pfi-method-index*
(:group method-index)
(:separate name-index)
((t :both) (list method-index name-index))
((nil) nil)
(otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*))))))
(defun pfi-install-pcl ()
(pfi-add-method-type)
(pfi-add-class-type))
(eval-when (eval load)
(when (boundp (quote il:*pfi-types*))
(pfi-install-pcl))
)
